perm filename M11B.OK[P11,LCS] blob sn#347632 filedate 1978-04-10 generic text, type C, neo UTF8
COMMENT āŠ—   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	CGEN1      FUNCTION GENERATOR 1 
C00016 ENDMK
CāŠ—;
CGEN1      FUNCTION GENERATOR 1 
C    *** MUSIC V ***     
      SUBROUTINEGEN1     
CC    DIMENSIONI(15000),P(100),IP(20)  
      COMMON I(1)/P/ P(1)/PARM/IP(1)
      N1=IP(2)+(IFIX(P(4))-1)*IP(6)    
      M1=7 
      SCLFT=IP(15)
 102  IF(P(M1+1))103,103,100    
 100  V1=P(M1-2)*SCLFT   
      V2=(P(M1)-P(M1-2))/(P(M1+1)-P(M1-1))*SCLFT     
      MA=N1+IFIX(P(M1-1))
      MB=N1+IFIX(P(M1+1))-1     
      DO 101J=MA,MB
      XJ=J-MA     
 101  I(J)=V1+V2*XJ      
      IF(IFIX(P(M1+1)).EQ.(IP(6)-1))GO TO 103   
      M1=M1+2     
      GO TO 102     
 103  I(MB+1)=P(M1)*SCLFT
      RETURN      
      END  
CGEN2      FUNCTION GENERATOR 2 
C    *** MUSIC V ***     
      SUBROUTINEGEN2     
      DIMENSION A(7000) 
CC    DIMENSIONI(15000),P(100),IP(20)  
      COMMON I(1)/P/ P(1)/PARM/IP(1)
      EQUIVALENCE(I,A)   
      SCLFT=IP(15)
      N1=IP(2)+(IFIX(P(4))-1)*IP(6)    
      N2=N1+IP(6)-1      
      DO 101K1=N1,N2      
 101  A(K1)=0.0   
      FAC=6.283185/(FLOAT(IP(6))-1.0)  
      NMAX=I(1)   
      N3=5+INT(ABS(P(NMAX)))-1  
      IF(N3-5)104,100,100
 100  DO 103J=5,N3 
      FACK=FAC*FLOAT(J-4)
      DO 102K=N1,N2
 102  A(K)=A(K)+SIN(FACK*FLOAT(K-N1))*P(J)    
 103  CONTINUE    
 104  N4=N3+1     
      N5=I(1)-1   
      IF(N5-N4)114,105,105      
 105  DO 107J1=N4,N5      
      FACK=FAC*FLOAT(J1-N4)     
      DO 106K1=N1,N2      
 106  A(K1)=A(K1)+COS(FACK*FLOAT(K1-N1))*P(J1)
 107  CONTINUE    
 114  CONTINUE    
      IF(P(NMAX))112,112,108    
 108  FMAX=0.0    
      DO 110K2=N1,N2      
      IF(ABS(A(K2))-FMAX)110,110,109   
 109  FMAX=ABS(A(K2))    
 110  CONTINUE    
 113  DO 111K3=N1,N2      
 111  I(K3)=(A(K3)*SCLFT*.99999)/FMAX  
      RETURN      
 112  FMAX=.99999 
      GO TO 113     
      END  

CDATA3     PASS 3 DATA INPUTING ROUTINE
C    *** MUSIC V ***     
      SUBROUTINE DATA (N)
      COMMON I(1)/P/ P(1) /FINOUT/JPEAK,NN,IPEAK
CC    COMMON I(15000),P(100)    
	EQUIVALENCE (K,I),(P2,P(2))
      READ (N)  K,(P(J),J=1,K)  
	TYPE 1,P2
CC    I(1)=K      
	IF(JPEAK.LE.IPEAK)RETURN
	TYPE 2,JPEAK
	IPEAK=JPEAK
C  TYPES OUT EACH NEW PEAK AMPL.
      RETURN      
1	FORMAT('+',F9.2,$)
2	FORMAT('+   AMPL=',I4,$)
      END  

CPARM      CONTROL DATA SPECIFICATION FOR PASS 3     
C    *** MUSIC V ***     
C   
C     IP(1) = NUMBER OF OP CODES
C     IP(2) = BEGINNING SUBSCRIPT OF FIRST FUNCTION  
C     IP(3) = STANDARD SAMPLING RATE   
C     IP(4) = BEGINNING SUBSCRIPT OF INSTRUMENT DEFINITIONS 
C     IP(5) = BEGINNING OF LOCATION TABLE FOR INSTRUMENT DEFINITIONS      
C     IP(6) = LENGTH OF FUNCTIONS      
C     IP(7) = BEGINNING OF NOTE CARD PARAMETERS      
C     IP(8) = LENGTH OF NOTE CARD PARAMETER BLOCKS   
C     IP(9) = NUMBER OF NOTE CARD PARAMETER BLOCKS   
C     IP(10)= BEGINNING OF OUTPUT DATA BLOCK  
C     IP(11)= SOUND ZERO (SILENCE VALUE)      
C     IP(12)= SCALE FACTOR FOR NOTE CARD PARAMETERS  
C     IP(13)= BEGINNING OF GENERATOR INPUT-OUTPUT BLOCKS    
C     IP(14)= LENGTH OF GENERATOR INPUT-OUTPUT BLOCKS
C     IP(15)= SCALE FACTOR FOR FUNCTIONS      
C   
      BLOCK DATA  
      COMMON /PARM/IP(20)
      DATA IP/12,512,10000, 7100, 7000,512, 6000,35,27,4487,2048,  
     1   10     ,4487,512,  "77777  ,5*0/
CCC   DATA IP/12,512,10000,14500,14400,512,13000,35,40,6657,2048,  
CCC  1  "1000000,6657,512,"377777777777,5*0/
C*****BIG NUMB. IS IBM360'S BIGGEST.  1  65536,6657,512,Z7FFFFFFF/      
      END  

      SUBROUTINE FROUT3(IDSK) 
C   TERMINATE OUTPUT     
      INTEGER PEAK
      COMMON I(1)/P/ P(1)/PARM/IP(1)/FINOUT/PEAK,NRSOR  
CC    COMMON I(15000),P(100)/PARM/IP(20)/FINOUT/PEAK,NRSOR  
      K=IP(10)    
      L=IP(10)+IP(14)-1  
      DO  1 J=K,L  
    1 I(J)=0      
      CALL SAMOUT(IDSK,IP(14))
CC    REWIND NWRITE      
CC    WRITE (6,10) PEAK,NRSOR   
      TYPE 10,PEAK,NRSOR
CC***    CALL EXIT   
      IF(IDSK.LT.0)CALL EXIT
      J=IP(10)
      L=J+1024
      DO 2 K=J,L
2     I(K)=0
C   WILL WRITE 1024 0'S ON DSK.
C///  CALL FASTOUT(I(J),1024)
C///  CALL FINFILE
      CALL EXIT
   10 FORMAT ('0PEAK AMPLITUDE WAS',I8/'0NUMBER OF SAMPLES OUT OF RANGE   
     1WAS',I8)    
      END  


CDSMOUT   DEBUG SAMOUT     'C////'=CHANGES FOR PDP11 VERSION
C *** MUSIC V *** 
C     DEBUG SAMOUT
      SUBROUTINE SAMOUT(IDSK,N)    
      DIMENSION IDBUF(1023),JDBUF(512)
 	EQUIVALENCE (IDBUF,JDBUF)
C//// DIMENSION IDBUF(3071)
CZ    DIMENSION IDBUF(2000),MS(3)
C*** IDSK IS FLAG TO WRITE SAMPLES ON DSK -- PDP *****
C*** IDBUF WILL STORE PACKED SAMPLES. ****
CC    DIMENSIONI(15000),T(10),P(100),IP(20)   
      COMMON I(1)/P/ P(1)/PARM/IP(1)/FINOUT/PEAK,NRSOR  
CC    COMMON I,P/PARM/IP/FINOUT/PEAK,NRSOR
      INTEGER PEAK
99    J=IDSK+1
      M1=IP(10)
      M2=0
      ISC=IP(12)
      IDSK=IDSK+N
C  COUNTS SAMPLES TO DATE
      DO 1 K=J,IDSK
      N1=I(M1+M2)/ISC
      IF(N1.GT.PEAK)PEAK=N1
      IDBUF(K)=N1
1     M2=M2+1
      IF(IDSK.LT.512)RETURN

	WRITE(23)JDBUF
      J=IDSK-512
      IF(J.LT.1)GO TO 4
      DO 5 K=1,J
5     IDBUF(K)=IDBUF(512+K)
4     IDSK=J
      RETURN
      END  

CERRO1     GENERAL ERROR ROUTINE
C    *** MUSIC V ***     
      SUBROUTINE ERROR(I) 
      TYPE 100,I  
  100 FORMAT (' ERROR OF TYPE',I5)     
      RETURN      
      END